Programming Languages Suite

home *** CD-ROM | disk | FTP | other *** search

/ Programming Languages Suite / ProgramD2.iso / Visual Database / Visual BASIC 5.0 (Ent. Edition) / Vb5ent Extractor.EXE / VB / SAMPLES / PGUIDE / VCR / VCR.FRM (.txt) < prev next >

Wrap

Visual Basic Form | 1996-09-16 | 18.7 KB | 600 lines

VERSION 5.00 Begin VB.Form frmVCR BackColor = &H00000000& Caption = "VBTV" ClientHeight = 7125 ClientLeft = 1170 ClientTop = 1470 ClientWidth = 7110 FillStyle = 0 'Solid Icon = "vcr.frx":0000 LinkTopic = "Form1" MaxButton = 0 'False ScaleHeight = 7125 ScaleWidth = 7110 Begin VB.CommandButton cmdSet Caption = "Set" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 4560 MaskColor = &H00000000& TabIndex = 13 ToolTipText = "Set the Timer for Recording" Top = 6000 Width = 855 End Begin VB.Timer tmr2 Enabled = 0 'False Left = 6240 Top = 3240 End Begin VB.Timer tmr1 Interval = 65535 Left = 6240 Top = 2640 End Begin VB.CommandButton cmdDown Caption = "Down" Height = 325 Left = 6120 MaskColor = &H00000000& TabIndex = 11 ToolTipText = "Channel selector" Top = 1440 Width = 735 End Begin VB.CommandButton cmdUp Caption = "Up" Height = 325 Left = 6120 MaskColor = &H00000000& TabIndex = 10 ToolTipText = "Channel selector" Top = 1080 Width = 735 End Begin VB.CommandButton cmdExit Cancel = -1 'True Caption = "Eject" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 5760 MaskColor = &H00000000& TabIndex = 7 ToolTipText = "Exit VBTV" Top = 6000 Width = 1095 End Begin VB.CommandButton cmdPause Caption = "ll" Enabled = 0 'False BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 1005 MaskColor = &H00000000& TabIndex = 6 ToolTipText = "Pause" Top = 6000 Width = 615 End Begin VB.CommandButton cmdRec Caption = "Rec" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 1650 MaskColor = &H00000000& TabIndex = 5 ToolTipText = "Record" Top = 6000 Width = 615 End Begin VB.CommandButton cmdForward Caption = ">>" BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 2955 MaskColor = &H00000000& TabIndex = 4 ToolTipText = "Fast Forward" Top = 6000 Width = 615 End Begin VB.CommandButton cmdRewind Caption = "<<" BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 2310 MaskColor = &H00000000& TabIndex = 3 ToolTipText = "Rewind" Top = 6000 Width = 615 End Begin VB.CommandButton cmdStop Caption = "Stop" Enabled = 0 'False BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 3600 MaskColor = &H00000000& TabIndex = 2 ToolTipText = "Stop" Top = 6000 Width = 615 End Begin VB.PictureBox picTV AutoRedraw = -1 'True BackColor = &H00C0C0C0& BorderStyle = 0 'None FillStyle = 2 'Horizontal Line BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00FFFFFF& Height = 4215 Left = 360 ScaleHeight = 4215 ScaleWidth = 5535 TabIndex = 1 Top = 240 Width = 5535 End Begin VB.CommandButton cmdPlay Caption = ">" BeginProperty Font Name = "MS Sans Serif" Size = 13.5 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 360 Left = 360 MaskColor = &H00000000& TabIndex = 0 ToolTipText = "Play" Top = 6000 Width = 615 End Begin VB.Line Line2 BorderColor = &H00808080& X1 = 0 X2 = 7080 Y1 = 4660 Y2 = 4660 End Begin VB.Line Line1 BorderColor = &H00FFFFFF& X1 = 0 X2 = 7080 Y1 = 4700 Y2 = 4700 End Begin VB.Shape shpPlay FillColor = &H0000FF00& FillStyle = 0 'Solid Height = 105 Left = 615 Shape = 3 'Circle Top = 5835 Visible = 0 'False Width = 105 End Begin VB.Shape shpForward FillColor = &H0000FF00& FillStyle = 0 'Solid Height = 105 Left = 3210 Shape = 3 'Circle Top = 5835 Visible = 0 'False Width = 105 End Begin VB.Shape shpRewind FillColor = &H0000FF00& FillStyle = 0 'Solid Height = 105 Left = 2565 Shape = 3 'Circle Top = 5835 Visible = 0 'False Width = 105 End Begin VB.Shape shpRec FillColor = &H000000FF& FillStyle = 0 'Solid Height = 105 Left = 1905 Shape = 3 'Circle Top = 5835 Visible = 0 'False Width = 105 End Begin VB.Shape shpPause FillColor = &H0000FF00& FillStyle = 0 'Solid Height = 105 Left = 1260 Shape = 3 'Circle Top = 5835 Visible = 0 'False Width = 105 End Begin VB.Image img2 Height = 1155 Left = 1680 Picture = "vcr.frx":0442 Top = 6720 Visible = 0 'False Width = 1155 End Begin VB.Image img1 Height = 1155 Left = 240 Picture = "vcr.frx":10CC Top = 6720 Visible = 0 'False Width = 1155 End Begin VB.Label lblTime Alignment = 2 'Center BackColor = &H00000000& BorderStyle = 1 'Fixed Single BeginProperty Font Name = "MS Sans Serif" Size = 18 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H000000FF& Height = 615 Left = 480 TabIndex = 12 Top = 4920 Width = 1935 End Begin VB.Label lblBrand BackStyle = 0 'Transparent Caption = "Microsoft Visual Basic VCR - Version 1.0" ForeColor = &H00FFFFFF& Height = 375 Left = 3360 TabIndex = 9 Top = 5160 Width = 2895 End Begin VB.Image imgTapeSlot BorderStyle = 1 'Fixed Single Height = 735 Left = 2640 Top = 4920 Width = 4215 End Begin VB.Label lblChannel Alignment = 2 'Center BackStyle = 0 'Transparent BorderStyle = 1 'Fixed Single Caption = "3" BeginProperty Font Name = "MS Sans Serif" Size = 24 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H0000FF00& Height = 615 Left = 6120 TabIndex = 8 ToolTipText = "Channel display" Top = 240 Width = 735 End Attribute VB_Name = "frmVCR" Attribute VB_Base = "0{FF90640B-E9E1-11CF-84BA-00AA00C007F0}" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_TemplateDerived = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False '********************************************** ' Purpose: Main form for the VCR sample ' application. Emulates a video cassette ' recorder using Visual Basic objects. '********************************************** Option Explicit ' Create an instance of the Tape class Dim Tape As New clsTape Dim vntChannel As Variant 'Channel number ' Constants for QBColor function Const vcrBlack = 0 Const vcrGreen = 2 Const vcrCyan = 3 Const vcrRed = 4 Const vcrMagenta = 5 Const vcrYellow = 6 Const vcrWhite = 7 Const vcrGray = 8 Const vcrLightBlue = 9 Const vcrLightGreen = 10 Const vcrLightCyan = 11 Const vcrLightRed = 12 Const vcrLightMagenta = 13 Private Sub cmdDown_Click() ' if in range, set the channel number If vntChannel > 2 Then vntChannel = vntChannel - 1 Else vntChannel = 13 End If ' assign the channel variable to the display lblChannel.Caption = vntChannel End Sub Private Sub cmdExit_Click() ' unload the form, release the reference Unload Me Set frmVCR = Nothing End Sub Private Sub cmdForward_Click() ' call the function to save the old channel SaveChannel vntChannel ' must be on channel 3 to play a tape vntChannel = 3 lblChannel.Caption = vntChannel ' Set the properties of the Tape class Tape.Forward = True Tape.Speed = 50 ' Start the timer tmr2.Enabled = True tmr2.Interval = Tape.Speed ' Call the function to update the controls ButtonManager frmVCR.cmdForward End Sub Private Sub cmdPause_Click() ' Stop the timer tmr2.Enabled = False ' Call the function to update the controls ButtonManager frmVCR.cmdPause End Sub Private Sub cmdPlay_Click() ' call the function to save the old channel SaveChannel vntChannel ' must be on channel 3 to play a tape vntChannel = 3 lblChannel.Caption = vntChannel ' Set the properties of the Tape class Tape.Forward = True Tape.Speed = 300 ' Start the timer tmr2.Enabled = True tmr2.Interval = Tape.Speed ' Call the function to update the controls ButtonManager frmVCR.cmdPlay End Sub Private Sub cmdRec_Click() Dim strStatus As String 'Display text ' call the function to save the old channel SaveChannel vntChannel ' Clear the display picTV.Cls ' Diplay the status strStatus = "Recording: Channel " & vntChannel picTV.Print strStatus strStatus = lblTime.Caption picTV.Print strStatus ' Call the function to update the controls ButtonManager frmVCR.cmdRec End Sub Private Sub cmdRewind_Click() ' call the function to save the old channel SaveChannel vntChannel ' must be on channel 3 to play a tape vntChannel = 3 lblChannel.Caption = vntChannel ' Set the properties of the Tape class Tape.Forward = False Tape.Speed = 50 ' Start the timer tmr2.Enabled = True tmr2.Interval = Tape.Speed ' Call the function to update the controls ButtonManager frmVCR.cmdRewind End Sub Private Sub cmdSet_Click() ' show the user entry form modally frmSetTime.Show vbModal End Sub Private Sub cmdStop_Click() Dim intChannel As Integer 'Channel number ' Stop the timer tmr2.Enabled = False ' Call the function to update the controls ButtonManager frmVCR.cmdStop ' Clear the display picTV.Cls ' restore the old channel intChannel = SaveChannel(0) vntChannel = intChannel lblChannel.Caption = vntChannel End Sub Private Sub cmdUp_Click() ' if in range, set the channel number If vntChannel < 13 Then vntChannel = vntChannel + 1 Else vntChannel = 2 End If ' assign the channel variable to the display lblChannel.Caption = vntChannel End Sub Private Sub Form_Load() ' Show the current time lblTime.Caption = Format((Now), "h:mm AM/PM") ' Set the height of the form frmVCR.Height = 6990 img1.Visible = True ' Display the form Me.Show ' set the initial channel vntChannel = 3 lblChannel.Caption = vntChannel End Sub Private Sub Form_Unload(Cancel As Integer) ' Release the references Set Tape = Nothing Set Recorder = Nothing Set frmVCR = Nothing End Sub Private Sub lblChannel_Change() ' Change the display color based on channel Select Case vntChannel Case 2 picTV.BackColor = QBColor(vcrGreen) Case 3 picTV.BackColor = QBColor(vcrWhite) Case 4 picTV.BackColor = QBColor(vcrRed) Case 5 picTV.BackColor = QBColor(vcrMagenta) Case 6 picTV.BackColor = QBColor(vcrYellow) Case 7 picTV.BackColor = QBColor(vcrCyan) Case 8 picTV.BackColor = QBColor(vcrGray) Case 9 picTV.BackColor = QBColor(vcrLightBlue) Case 10 picTV.BackColor = QBColor(vcrLightGreen) Case 11 picTV.BackColor = QBColor(vcrLightCyan) Case 12 picTV.BackColor = QBColor(vcrLightRed) Case 13 picTV.BackColor = QBColor(vcrLightMagenta) End Select ' Clear the display picTV.Cls ' Display the channel & time picTV.Print "Channel: " & vntChannel picTV.Print lblTime.Caption End Sub Private Sub tmr1_Timer() ' Update the time display lblTime.Caption = Format((Now), "h:mm AM/PM") ' If the Recorder property is turned on If Recorder.Enabled = True Then ' If it's time to record If Recorder.StartRecording = lblTime.Caption Then ' Start "recording" vntChannel = Recorder.Channel lblChannel.Caption = vntChannel ' Activate the Record button cmdRec.Value = True ' clear the property in the Recorder class Recorder.StartRecording = Empty End If Else ' If it's time to stop recording If Recorder.StopRecording = lblTime.Caption Then ' Activate the Stop button cmdStop.Value = True ' clear the property in the Recorder class Recorder.StopRecording = Empty End If End If End Sub Private Sub tmr2_Timer() Dim intWidth As Integer 'Width value Dim intLeft As Integer 'Left value Dim objImage As Control 'Image control ' Get the width of the display intWidth = picTV.Width ' Call the method in the Tape class ' to "play" the tape. Tape.Animate intWidth ' Retrieve the Left property from the class intLeft = Tape.Left ' Show either the first or second image If img1.Visible = True Then img1.Visible = False Set objImage = img2 Else img1.Visible = True Set objImage = img1 End If ' Clear the display picTV.Cls ' Show the new image in the new location picTV.PaintPicture objImage.Picture, intLeft, 1200 End Sub